home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / nneething.el.z / nneething.el
Encoding:
Text File  |  1998-05-21  |  10.5 KB  |  352 lines
  1. ;;; nneething.el --- random file access for Gnus
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (eval-when-compile (require 'cl))
  30.  
  31. (require 'nnheader)
  32. (require 'nnmail)
  33. (require 'nnoo)
  34. (require 'gnus-util)
  35.  
  36. (nnoo-declare nneething)
  37.  
  38. (defvoo nneething-map-file-directory "~/.nneething/"
  39.   "Where nneething stores the map files.")
  40.  
  41. (defvoo nneething-map-file ".nneething"
  42.   "Name of the map files.")
  43.  
  44. (defvoo nneething-exclude-files nil
  45.   "Regexp saying what files to exclude from the group.
  46. If this variable is nil, no files will be excluded.")
  47.  
  48.  
  49.  
  50. ;;; Internal variables.
  51.  
  52. (defconst nneething-version "nneething 1.0"
  53.   "nneething version.")
  54.  
  55. (defvoo nneething-current-directory nil
  56.   "Current news group directory.")
  57.  
  58. (defvoo nneething-status-string "")
  59.  
  60. (defvoo nneething-message-id-number 0)
  61. (defvoo nneething-work-buffer " *nneething work*")
  62.  
  63. (defvoo nneething-group nil)
  64. (defvoo nneething-map nil)
  65. (defvoo nneething-read-only nil)
  66. (defvoo nneething-active nil)
  67.  
  68.  
  69.  
  70. ;;; Interface functions.
  71.  
  72. (nnoo-define-basics nneething)
  73.  
  74. (deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
  75.   (nneething-possibly-change-directory group)
  76.  
  77.   (save-excursion
  78.     (set-buffer nntp-server-buffer)
  79.     (erase-buffer)
  80.     (let* ((number (length articles))
  81.        (count 0)
  82.        (large (and (numberp nnmail-large-newsgroup)
  83.                (> number nnmail-large-newsgroup)))
  84.        article file)
  85.  
  86.       (if (stringp (car articles))
  87.       'headers
  88.  
  89.     (while (setq article (pop articles))
  90.       (setq file (nneething-file-name article))
  91.  
  92.       (when (and (file-exists-p file)
  93.              (or (file-directory-p file)
  94.              (not (zerop (nnheader-file-size file)))))
  95.         (insert (format "221 %d Article retrieved.\n" article))
  96.         (nneething-insert-head file)
  97.         (insert ".\n"))
  98.  
  99.       (incf count)
  100.  
  101.       (and large
  102.            (zerop (% count 20))
  103.            (message "nneething: Receiving headers... %d%%"
  104.             (/ (* count 100) number))))
  105.  
  106.     (when large
  107.       (message "nneething: Receiving headers...done"))
  108.  
  109.     (nnheader-fold-continuation-lines)
  110.     'headers))))
  111.  
  112. (deffoo nneething-request-article (id &optional group server buffer)
  113.   (nneething-possibly-change-directory group)
  114.   (let ((file (unless (stringp id)
  115.         (nneething-file-name id)))
  116.     (nntp-server-buffer (or buffer nntp-server-buffer)))
  117.     (and (stringp file)            ; We did not request by Message-ID.
  118.      (file-exists-p file)        ; The file exists.
  119.      (not (file-directory-p file))    ; It's not a dir.
  120.      (save-excursion
  121.        (nnmail-find-file file)    ; Insert the file in the nntp buf.
  122.        (unless (nnheader-article-p)    ; Either it's a real article...
  123.          (goto-char (point-min))
  124.          (nneething-make-head file (current-buffer)) ; ... or we fake some headers.
  125.          (insert "\n"))
  126.        t))))
  127.  
  128. (deffoo nneething-request-group (group &optional server dont-check)
  129.   (nneething-possibly-change-directory group server)
  130.   (unless dont-check
  131.     (nneething-create-mapping)
  132.     (if (> (car nneething-active) (cdr nneething-active))
  133.     (nnheader-insert "211 0 1 0 %s\n" group)
  134.       (nnheader-insert
  135.        "211 %d %d %d %s\n"
  136.        (- (1+ (cdr nneething-active)) (car nneething-active))
  137.        (car nneething-active) (cdr nneething-active)
  138.        group)))
  139.   t)
  140.  
  141. (deffoo nneething-request-list (&optional server dir)
  142.   (nnheader-report 'nneething "LIST is not implemented."))
  143.  
  144. (deffoo nneething-request-newgroups (date &optional server)
  145.   (nnheader-report 'nneething "NEWSGROUPS is not implemented."))
  146.  
  147. (deffoo nneething-request-type (group &optional article)
  148.   'unknown)
  149.  
  150. (deffoo nneething-close-group (group &optional server)
  151.   (setq nneething-current-directory nil)
  152.   t)
  153.  
  154. (deffoo nneething-open-server (server &optional defs)
  155.   (nnheader-init-server-buffer)
  156.   (if (nneething-server-opened server)
  157.       t
  158.     (unless (assq 'nneething-directory defs)
  159.       (setq defs (append defs (list (list 'nneething-directory server)))))
  160.     (nnoo-change-server 'nneething server defs)))
  161.  
  162.  
  163. ;;; Internal functions.
  164.  
  165. (defun nneething-possibly-change-directory (group &optional server)
  166.   (when (and server
  167.          (not (nneething-server-opened server)))
  168.     (nneething-open-server server))
  169.   (when (and group
  170.          (not (equal nneething-group group)))
  171.     (setq nneething-group group)
  172.     (setq nneething-map nil)
  173.     (setq nneething-active (cons 1 0))
  174.     (nneething-create-mapping)))
  175.  
  176. (defun nneething-map-file ()
  177.   ;; We make sure that the .nneething directory exists.
  178.   (gnus-make-directory nneething-map-file-directory)
  179.   ;; We store it in a special directory under the user's home dir.
  180.   (concat (file-name-as-directory nneething-map-file-directory)
  181.       nneething-group nneething-map-file))
  182.  
  183. (defun nneething-create-mapping ()
  184.   ;; Read nneething-active and nneething-map.
  185.   (when (file-exists-p nneething-directory)
  186.     (let ((map-file (nneething-map-file))
  187.       (files (directory-files nneething-directory))
  188.       touched map-files)
  189.       (when (file-exists-p map-file)
  190.     (ignore-errors
  191.       (load map-file nil t t)))
  192.       (unless nneething-active
  193.     (setq nneething-active (cons 1 0)))
  194.       ;; Old nneething had a different map format.
  195.       (when (and (cdar nneething-map)
  196.          (atom (cdar nneething-map)))
  197.     (setq nneething-map
  198.           (mapcar (lambda (n)
  199.             (list (cdr n) (car n)
  200.                   (nth 5 (file-attributes
  201.                       (nneething-file-name (car n))))))
  202.               nneething-map)))
  203.       ;; Remove files matching the exclusion regexp.
  204.       (when nneething-exclude-files
  205.     (let ((f files)
  206.           prev)
  207.       (while f
  208.         (if (string-match nneething-exclude-files (car f))
  209.         (if prev (setcdr prev (cdr f))
  210.           (setq files (cdr files)))
  211.           (setq prev f))
  212.         (setq f (cdr f)))))
  213.       ;; Remove deleted files from the map.
  214.       (let ((map nneething-map)
  215.         prev)
  216.     (while map
  217.       (if (and (member (cadar map) files)
  218.            ;; We also remove files that have changed mod times.
  219.            (equal (nth 5 (file-attributes
  220.                   (nneething-file-name (cadar map))))
  221.               (caddar map)))
  222.           (progn
  223.         (push (cadar map) map-files)
  224.         (setq prev map))
  225.         (setq touched t)
  226.         (if prev
  227.         (setcdr prev (cdr map))
  228.           (setq nneething-map (cdr nneething-map))))
  229.       (setq map (cdr map))))
  230.       ;; Find all new files and enter them into the map.
  231.       (while files
  232.     (unless (member (car files) map-files)
  233.       ;; This file is not in the map, so we enter it.
  234.       (setq touched t)
  235.       (setcdr nneething-active (1+ (cdr nneething-active)))
  236.       (push (list (cdr nneething-active) (car files)
  237.               (nth 5 (file-attributes
  238.                   (nneething-file-name (car files)))))
  239.         nneething-map))
  240.     (setq files (cdr files)))
  241.       (when (and touched
  242.          (not nneething-read-only))
  243.     (nnheader-temp-write map-file
  244.       (insert "(setq nneething-map '")
  245.       (gnus-prin1 nneething-map)
  246.       (insert ")\n(setq nneething-active '")
  247.       (gnus-prin1 nneething-active)
  248.       (insert ")\n"))))))
  249.  
  250. (defun nneething-insert-head (file)
  251.   "Insert the head of FILE."
  252.   (when (nneething-get-head file)
  253.     (insert-buffer-substring nneething-work-buffer)
  254.     (goto-char (point-max))))
  255.  
  256. (defun nneething-make-head (file &optional buffer)
  257.   "Create a head by looking at the file attributes of FILE."
  258.   (let ((atts (file-attributes file)))
  259.     (insert
  260.      "Subject: " (file-name-nondirectory file) "\n"
  261.      "Message-ID: <nneething-"
  262.      (int-to-string (incf nneething-message-id-number))
  263.      "@" (system-name) ">\n"
  264.      (if (equal '(0 0) (nth 5 atts)) ""
  265.        (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
  266.      (or (when buffer
  267.        (save-excursion
  268.          (set-buffer buffer)
  269.          (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
  270.            (concat "From: " (match-string 0) "\n"))))
  271.      (nneething-from-line (nth 2 atts) file))
  272.      (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
  273.      (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
  274.        "")
  275.      (if buffer
  276.      (save-excursion
  277.        (set-buffer buffer)
  278.        (concat "Lines: " (int-to-string
  279.                   (count-lines (point-min) (point-max)))
  280.            "\n"))
  281.        "")
  282.      )))
  283.  
  284. (defun nneething-from-line (uid &optional file)
  285.   "Return a From header based of UID."
  286.   (let* ((login (condition-case nil
  287.             (user-login-name uid)
  288.           (error
  289.            (cond ((= uid (user-uid)) (user-login-name))
  290.              ((zerop uid) "root")
  291.              (t (int-to-string uid))))))
  292.      (name (condition-case nil
  293.            (user-full-name uid)
  294.          (error
  295.           (cond ((= uid (user-uid)) (user-full-name))
  296.             ((zerop uid) "Ms. Root")))))
  297.      (host (if  (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
  298.            (prog1
  299.                (substring file
  300.                   (match-beginning 1)
  301.                   (match-end 1))
  302.              (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
  303.                (setq login (substring file
  304.                           (match-beginning 2)
  305.                           (match-end 2))
  306.                  name nil)))
  307.          (system-name))))
  308.     (concat "From: " login "@" host
  309.         (if name (concat " (" name ")") "") "\n")))
  310.  
  311. (defun nneething-get-head (file)
  312.   "Either find the head in FILE or make a head for FILE."
  313.   (save-excursion
  314.     (set-buffer (get-buffer-create nneething-work-buffer))
  315.     (setq case-fold-search nil)
  316.     (buffer-disable-undo (current-buffer))
  317.     (erase-buffer)
  318.     (cond
  319.      ((not (file-exists-p file))
  320.       ;; The file do not exist.
  321.       nil)
  322.      ((or (file-directory-p file)
  323.       (file-symlink-p file))
  324.       ;; It's a dir, so we fudge a head.
  325.       (nneething-make-head file) t)
  326.      (t
  327.       ;; We examine the file.
  328.       (nnheader-insert-head file)
  329.       (if (nnheader-article-p)
  330.       (delete-region
  331.        (progn
  332.          (goto-char (point-min))
  333.          (or (and (search-forward "\n\n" nil t)
  334.               (1- (point)))
  335.          (point-max)))
  336.        (point-max))
  337.     (goto-char (point-min))
  338.     (nneething-make-head file (current-buffer))
  339.     (delete-region (point) (point-max)))
  340.       t))))
  341.  
  342. (defun nneething-file-name (article)
  343.   "Return the file name of ARTICLE."
  344.   (concat (file-name-as-directory nneething-directory)
  345.       (if (numberp article)
  346.           (cadr (assq article nneething-map))
  347.         article)))
  348.  
  349. (provide 'nneething)
  350.  
  351. ;;; nneething.el ends here
  352.